home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clx.lha / clx / requests.l < prev    next >
Lisp/Scheme  |  1988-09-12  |  61KB  |  1,697 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
  2.  
  3. ;;;
  4. ;;;             TEXAS INSTRUMENTS INCORPORATED
  5. ;;;                  P.O. BOX 2909
  6. ;;;                   AUSTIN, TEXAS 78769
  7. ;;;
  8. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  9. ;;;
  10. ;;; Permission is granted to any individual or institution to use, copy, modify,
  11. ;;; and distribute this software, provided that this complete copyright and
  12. ;;; permission notice is maintained, intact, in all copies and supporting
  13. ;;; documentation.
  14. ;;;
  15. ;;; Texas Instruments Incorporated provides this software "as is" without
  16. ;;; express or implied warranty.
  17. ;;;
  18.  
  19. (in-package 'xlib :use '(lisp))
  20.  
  21. (export '(create-window
  22.       destroy-window
  23.       destroy-subwindows
  24.       add-to-save-set
  25.       remove-from-save-set
  26.       reparent-window
  27.       map-window
  28.       map-subwindows
  29.       unmap-window
  30.       unmap-subwindows
  31.       circulate-window-up
  32.       circulate-window-down
  33.       query-tree
  34.       intern-atom
  35.       find-atom
  36.       atom-name
  37.       change-property
  38.       delete-property
  39.       get-property
  40.       rotate-properties
  41.       list-properties
  42.       set-selection-owner
  43.       selection-owner
  44.       selection-owner
  45.       convert-selection
  46.       send-event
  47.       grab-pointer
  48.       ungrab-pointer
  49.       grab-button
  50.       ungrab-button
  51.       change-active-pointer-grab
  52.       grab-keyboard
  53.       ungrab-keyboard
  54.       grab-key
  55.       ungrab-key
  56.       allow-events
  57.       grab-server
  58.       ungrab-server
  59.       with-server-grabbed
  60.       query-pointer
  61.       pointer-position
  62.       global-pointer-position
  63.       motion-events
  64.       translate-coordinates
  65.       warp-pointer
  66.       warp-pointer-relative
  67.       warp-pointer-if-inside
  68.       warp-pointer-relative-if-inside
  69.       set-input-focus
  70.       input-focus
  71.       query-keymap
  72.       create-pixmap
  73.       free-pixmap
  74.       clear-area
  75.       copy-area
  76.       copy-plane
  77.       create-colormap
  78.       free-colormap
  79.       copy-colormap-and-free
  80.       install-colormap
  81.       uninstall-colormap
  82.       installed-colormaps
  83.       alloc-color
  84.       alloc-color-cells
  85.       alloc-color-planes
  86.       free-colors
  87.       store-color
  88.       store-colors
  89.       query-colors
  90.       lookup-color
  91.       create-cursor
  92.       create-glyph-cursor
  93.       free-cursor
  94.       recolor-cursor
  95.       query-best-cursor
  96.       query-best-tile
  97.       query-best-stipple
  98.       query-extension
  99.       list-extensions
  100.       change-keyboard-control
  101.       keyboard-control
  102.       bell
  103.       pointer-mapping
  104.       set-pointer-mapping
  105.       pointer-mapping
  106.       change-pointer-control
  107.       pointer-control
  108.       set-screen-saver
  109.       screen-saver
  110.       activate-screen-saver
  111.       reset-screen-saver
  112.       add-access-host
  113.       remove-access-host
  114.       access-hosts
  115.       access-control
  116.       set-access-control
  117.       access-control
  118.       close-down-mode
  119.       set-close-down-mode
  120.       kill-client
  121.       kill-temporary-clients
  122. ;;      NO-OPERATION
  123.       ))
  124.  
  125. (defun create-window (&key
  126.               (parent (required-arg parent))
  127.               (x (required-arg x))
  128.               (y (required-arg y))
  129.               (width (required-arg width))
  130.               (height (required-arg height))
  131.               (depth 0) (border-width 0)
  132.               (class :copy) (visual :copy)
  133.               background border
  134.               bit-gravity gravity
  135.               backing-store backing-planes backing-pixel save-under
  136.               event-mask do-not-propagate-mask override-redirect
  137.               colormap cursor)
  138.   ;; Display is obtained from parent.  Only non-nil attributes are passed on in
  139.   ;; the request: the function makes no assumptions about what the actual protocol
  140.   ;; defaults are.  Width and height are the inside size, excluding border.
  141.   (declare (type window parent) ; required
  142.        (type int16 x y) ;required
  143.        (type card16 width height) ;required
  144.        (type card16 depth border-width)
  145.        (type (member :copy :input-output :input-only) class)
  146.        (type (or (member :copy) card29) visual)
  147.        (type (or null (member :none :parent-relative) pixel pixmap) background)
  148.        (type (or null (member :copy) pixel pixmap) border)
  149.        (type (or null bit-gravity) bit-gravity)
  150.        (type (or null win-gravity) gravity)
  151.        (type (or null (member :not-useful :when-mapped :always)) backing-store)
  152.        (type (or null pixel) backing-planes backing-pixel)
  153.        (type (or null event-mask) event-mask)
  154.        (type (or null device-event-mask) do-not-propagate-mask)
  155.        (type (or null (member :on :off)) save-under override-redirect)
  156.        (type (or null (member :copy) colormap) colormap)
  157.        (type (or null (member :none) cursor) cursor))
  158.   (declare-values window)
  159.   (let* ((display (window-display parent))
  160.      (window (make-window :display display))
  161.      (wid (allocate-resource-id display window 'window))
  162.      back-pixmap back-pixel
  163.      border-pixmap border-pixel)
  164.     (declare (type display display)
  165.          (type window window)
  166.          (type resource-id wid)
  167.          (type (or null resource-id) back-pixmap border-pixmap)
  168.          (type (or null pixel) back-pixel border-pixel))
  169.     (setf (window-id window) wid)
  170.     (case background
  171.       ((nil) nil)
  172.       (:none (setq back-pixmap 0))
  173.       (:parent-relative (setq back-pixmap 1))
  174.       (otherwise
  175.        (if (type? background 'pixmap)
  176.        (setq back-pixmap (pixmap-id background))
  177.      (if (integerp background)
  178.          (setq back-pixel background)
  179.        (x-type-error background
  180.              '(or null (member :none :parent-relative) integer pixmap))))))
  181.     (case border
  182.       ((nil) nil)
  183.       (:copy (setq border-pixmap 1))
  184.       (otherwise
  185.        (if (type? border 'pixmap)
  186.        (setq border-pixmap (pixmap-id border))
  187.      (if (integerp border)
  188.          (setq border-pixel border)
  189.        (x-type-error border '(or null (member :copy) integer pixmap))))))
  190.     (when event-mask
  191.       (setq event-mask (encode-event-mask event-mask)))
  192.     (when do-not-propagate-mask
  193.       (setq do-not-propagate-mask (encode-device-event-mask do-not-propagate-mask)))
  194.  
  195.                         ;Make the request
  196.     (with-buffer-request (display *x-createwindow*)
  197.       (data depth)
  198.       (resource-id wid)
  199.       (window parent)
  200.       (int16 x y)
  201.       (card16 width height border-width)
  202.       ((member16 :copy :input-output :input-only) class)
  203.       (resource-id (if (eq visual :copy) 0 visual))
  204.       (mask ((or null card32) back-pixmap back-pixel border-pixmap border-pixel)
  205.         ((or null (member-vector *bit-gravity-vector*)) bit-gravity)
  206.         ((or null (member-vector *win-gravity-vector*)) gravity)
  207.         ((or null (member :not-useful :when-mapped :always)) backing-store)
  208.         ((or null card32)  backing-planes backing-pixel)
  209.         ((or null (member :off :on)) override-redirect save-under)
  210.         ((or null card32) event-mask do-not-propagate-mask)
  211.         ((or null (member %error :copy) colormap) colormap)
  212.         ((or null (member :none) cursor) cursor)))
  213.     window))
  214.  
  215. (defun destroy-window (window)
  216.   (declare (type window window))
  217.   (with-buffer-request ((window-display window) *x-destroywindow*)
  218.     (window window)))
  219.  
  220. (defun destroy-subwindows (window)
  221.   (declare (type window window))
  222.   (with-buffer-request ((window-display window) *x-destroysubwindows*)
  223.     (window window)))
  224.  
  225. (defun add-to-save-set (window)
  226.   (declare (type window window))
  227.   (with-buffer-request ((window-display window) *x-changesaveset*)
  228.     (data 0)
  229.     (window window)))
  230.  
  231. (defun remove-from-save-set (window)
  232.   (declare (type window window))
  233.   (with-buffer-request ((window-display window) *x-changesaveset*)
  234.     (data 1)
  235.     (window window)))
  236.  
  237. (defun reparent-window (window parent x y)
  238.   (declare (type window window parent)
  239.        (type int16 x y))
  240.   (with-buffer-request ((window-display window) *x-reparentwindow*)
  241.     (window window parent)
  242.     (int16 x y)))
  243.  
  244. (defun map-window (window)
  245.   (declare (type window window))
  246.   (with-buffer-request ((window-display window) *x-mapwindow*)
  247.     (window window)))
  248.  
  249. (defun map-subwindows (window)
  250.   (declare (type window window))
  251.   (with-buffer-request ((window-display window) *x-mapsubwindows*)
  252.     (window window)))
  253.  
  254. (defun unmap-window (window)
  255.   (declare (type window window))
  256.   (with-buffer-request ((window-display window) *x-unmapwindow*)
  257.     (window window)))
  258.  
  259. (defun unmap-subwindows (window)
  260.   (declare (type window window))
  261.   (with-buffer-request ((window-display window) *x-unmapsubwindows*)
  262.     (window window)))
  263.  
  264. (defun circulate-window-up (window)
  265.   (declare (type window window))
  266.   (with-buffer-request ((window-display window) *x-circulatewindow*)
  267.     (data 0)
  268.     (window window)))
  269.  
  270. (defun circulate-window-down (window)
  271.   (declare (type window window))
  272.   (with-buffer-request ((window-display window) *x-circulatewindow*)
  273.     (data 1)
  274.     (window window)))
  275.  
  276. (defun query-tree (window &key (result-type 'list))
  277.   (declare (type window window)
  278.        (type t result-type)) ;;type specifier
  279.   (declare-values (sequence window) parent root)
  280.   (let ((display (window-display window))
  281.     sequence parent root)
  282.     (with-display (display)
  283.       (with-buffer-request (display *x-querytree* :no-after)
  284.     (window window))
  285.       (wait-for-reply display nil)
  286.       (reading-buffer-reply (display :sizes (8 16 32))
  287.     (let ((nchildren (card16-get 16)))
  288.       (setq root (window-get 8)
  289.         parent (resource-id-get 12)
  290.         sequence (sequence-get :length nchildren :result-type result-type))
  291.       ;; Parent is NIL for root window
  292.       (setq parent (and (plusp parent) (lookup-window display parent)))
  293.       (dotimes (i nchildren)        ; Convert ID's to window's
  294.         (setf (elt sequence i) (lookup-window display (elt sequence i)))))))
  295.     (display-invoke-after-function display)
  296.     (values sequence parent root)))
  297.  
  298. ;; Although atom-ids are not visible in the normal user interface, atom-ids might
  299. ;; appear in window properties and other user data, so conversion hooks are needed.
  300.  
  301. (defun intern-atom (display name)
  302.   (declare (type display display)
  303.        (type xatom name))
  304.   (declare-values card29)
  305.   (or (atom-id name display)
  306.       (let ((string (string name))
  307.         id)
  308.     (with-display (display)
  309.       (with-buffer-request (display *x-internatom* :no-after)
  310.         (data 0)
  311.         (card16 (length string))
  312.         (pad16 nil)
  313.         (string string))
  314.       (with-buffer-reply (display 12 :sizes 32)
  315.         (setq id (resource-id-get 8)))
  316.       (let ((keyword (if (keywordp name) name (kintern string))))
  317.         (setf (atom-id keyword display) id)
  318.         (save-id display id keyword)))
  319.     (display-invoke-after-function display)
  320.     id)))
  321.  
  322. (defun find-atom (display name)
  323.   ;; Same as INTERN-ATOM, but with the ONLY-IF-EXISTS flag True
  324.   (declare (type display display)
  325.        (type xatom name))
  326.   (declare-values (or null card29))
  327.   (or (atom-id name display)
  328.       (let ((string (string name))
  329.         id)
  330.     (with-display (display)
  331.       (with-buffer-request (display *x-internatom* :no-after)
  332.         (data 1)
  333.         (card16 (length string))
  334.         (pad16 nil)
  335.         (string string))
  336.       (with-buffer-reply (display 12 :sizes 32)
  337.         (setq id (or-get 8 null resource-id)))
  338.       (when id 
  339.         (let ((keyword (if (keywordp name) name (kintern string))))
  340.           (setf (atom-id keyword display) id)
  341.           (save-id display id keyword))))
  342.     (display-invoke-after-function display)
  343.     id)))
  344.  
  345. ;; Use LOOKUP-XATOM instead
  346. (proclaim '(inline atom-name))
  347. (defun atom-name (display atom-id)
  348.   (declare (type display display)
  349.        (type card29 atom-id))
  350.   (declare-values keyword)
  351.   (lookup-xatom display atom-id))
  352.  
  353. (defun atom-name-internal (display atom-id)
  354.   ;; Called only by LOOKUP-XATOM
  355.   (declare (type display display)
  356.        (type card29 atom-id)
  357.        (values keyword))
  358.   (let (keyword)
  359.     (with-display (display)
  360.       (with-buffer-request (display *x-getatomname* :no-after)
  361.     (card29 atom-id))
  362.       (with-buffer-reply (display nil :sizes (16))
  363.     (setq keyword (string-get (card16-get 8))))
  364.       (setq keyword (kintern keyword))
  365.       (setf (atom-id keyword display) atom-id))
  366.     (display-invoke-after-function display)
  367.     keyword))
  368.  
  369. (defun change-property (window property data type format
  370.                &key (mode :replace) (start 0) end transform)
  371.   ; Start and end affect sub-sequence extracted from data.
  372.   ; Transform is applied to each extracted element.
  373.   (declare (type window window)
  374.        (type xatom property type)
  375.        (type (member 8 16 32) format)
  376.        (type sequence data)
  377.        (type (member :replace :prepend :append) mode)
  378.        (type array-index start)
  379.        (type (or null array-index) end)
  380.        (type t transform))            ;(or null (function (t) integer))
  381.   (unless end (setq end (length data)))
  382.   (let* ((display (window-display window))
  383.      (length (- end start))
  384.      (property-id (intern-atom display property))
  385.      (type-id (intern-atom display type)))
  386.     (declare (type display display)
  387.          (type array-index length)
  388.          (type resource-id property-id type-id))
  389.     (with-buffer-request (display *x-changeproperty*)
  390.       ((data (member :replace :prepend :append)) mode)
  391.       (window window)
  392.       (resource-id property-id type-id)
  393.       (card8 format)
  394.       (card32 length)
  395.       (progn
  396.     (ecase format
  397.       (8  (sequence-put 24 data :format card8
  398.                 :start start :end end :transform transform))
  399.       (16 (sequence-put 24 data :format card16
  400.                 :start start :end end :transform transform))
  401.       (32 (sequence-put 24 data :format card32
  402.                 :start start :end end :transform transform)))))))
  403.  
  404. (defun delete-property (window property)
  405.   (declare (type window window)
  406.        (type xatom property))
  407.   (let* ((display (window-display window))
  408.      (property-id (intern-atom display property)))
  409.     (declare (type display display)
  410.          (type resource-id property-id))
  411.     (with-buffer-request (display *x-deleteproperty*)
  412.       (window window)
  413.       (resource-id property-id))))
  414.  
  415. (defun get-property (window property
  416.              &key type (start 0) end delete-p (result-type 'list) transform)
  417.   ;; Transform is applied to each integer retrieved.
  418.   (declare (type window window)
  419.        (type xatom property)
  420.        (type (or null xatom) type)
  421.        (type array-index start)
  422.        (type (or null array-index) end)
  423.        (type boolean delete-p)
  424.        (type t result-type)            ;a sequence type
  425.        (type t transform))            ;(or null (function (integer) t))
  426.   (declare-values data (or null type) format bytes-after)
  427.   (let* ((display (window-display window))
  428.      (data nil)
  429.      (property-id (intern-atom display property))
  430.      (type-id (and type (intern-atom display type)))
  431.      reply-type reply-format bytes-after)
  432.     (declare (type display display)
  433.          (type resource-id property-id)
  434.          (type (or null resource-id) type-id))
  435.     (with-display (display)
  436.       (with-buffer-request (display *x-getproperty* :no-after)
  437.     ((data boolean) delete-p)
  438.     (window window)
  439.     (resource-id property-id)
  440.     ((or null resource-id) type-id)
  441.     (card32 start)
  442.     (card32 (- (or end 64000) start)))
  443.       (with-buffer-reply (display nil :sizes (8 32))
  444.     (setq reply-format (card8-get 1)
  445.           reply-type (card32-get 8)
  446.           bytes-after (card32-get 12))
  447.     (let ((nitems (card32-get 16)))
  448.       (when (plusp nitems)
  449.         (setq data
  450.           (ecase reply-format
  451.             (0  nil) ;; (make-sequence result-type 0)) ;; Property not found.
  452.             (8  (sequence-get :result-type result-type :format card8
  453.                       :length nitems :transform transform))
  454.             
  455.             (16 (sequence-get :result-type result-type :format card16
  456.                       :length nitems :transform transform))
  457.             
  458.             (32 (sequence-get :result-type result-type :format card32
  459.                       :length nitems :transform transform))))))))
  460.     (display-invoke-after-function display)
  461.     (values data (and (plusp reply-type) (lookup-xatom display reply-type))
  462.         reply-format bytes-after)))
  463.  
  464. (defun rotate-properties (window properties &optional (delta 1))
  465.   ;; Positive rotates left, negative rotates right (opposite of actual protocol request).
  466.   (declare (type window window)
  467.        (type sequence properties) ;; sequence of xatom
  468.        (type int16 delta))
  469.   (let* ((display (window-display window))
  470.      (length (length properties))
  471.      (sequence (make-array length)))
  472.     (declare (type display display)
  473.          (type array-index length))
  474.     (with-vector (sequence vector)
  475.       (with-display (display)
  476.     ;; Atoms must be interned before the RotateProperties request
  477.     ;; is started to allow InternAtom requests to be made.
  478.     (dotimes (i length)
  479.       (setf (aref sequence i) (intern-atom display (elt properties i))))
  480.     (with-buffer-request (display *x-rotateproperties*)
  481.       (window window)
  482.       (card16 length)
  483.       (int16 (- delta))
  484.       ((sequence :end length) sequence))
  485.     nil))))
  486.  
  487. (defun list-properties (window &key (result-type 'list))
  488.   (declare (type window window)
  489.        (type t result-type)) ;; a sequence type
  490.   (declare-values (sequence keyword))
  491.   (let ((display (window-display window))
  492.     seq)
  493.     (with-display (display)
  494.       (with-buffer-request (display *x-listproperties* :no-after)
  495.     (window window))
  496.       (with-buffer-reply (display nil :sizes 16)
  497.     (let ((nproperties (card16-get 8)))
  498.       (setq seq (sequence-get :result-type result-type :length nproperties)))))
  499.     (display-invoke-after-function display)
  500.     ;; lookup the atoms in the sequence
  501.     (if (listp seq)
  502.     (do ((elt seq (cdr elt)))
  503.         ((endp elt) seq)
  504.       (setf (car elt) (lookup-xatom display (car elt))))
  505.       (dotimes (i (length seq) seq)
  506.     (setf (aref seq i) (lookup-xatom display (aref seq i)))))))
  507.  
  508. (defun selection-owner (display selection)
  509.   (declare (type display display)
  510.        (type xatom selection))
  511.   (declare-values (or null window))
  512.   (let ((selection-id (intern-atom display selection))
  513.     window)
  514.     (declare (type resource-id selection-id))
  515.     (with-display (display)
  516.       (with-buffer-request (display *x-getselectionowner* :no-after)
  517.     (resource-id selection-id))
  518.       (with-buffer-reply (display 12 :sizes 32)
  519.     (setq window (resource-id-or-nil-get 8)))
  520.       (when window
  521.     (setq window (lookup-window display window))))
  522.     (display-invoke-after-function display)
  523.     window))
  524.  
  525. (defun set-selection-owner (display selection owner &optional time)
  526.   (declare (type display display)
  527.        (type xatom selection)
  528.        (type (or null window) owner)
  529.        (type timestamp time))
  530.   (let ((selection-id (intern-atom display selection)))
  531.     (declare (type resource-id selection-id))
  532.     (with-buffer-request (display *x-setselectionowner*)
  533.       ((or null window) owner)
  534.       (resource-id selection-id)
  535.       ((or null card32) time))
  536.     owner))
  537.  
  538. (defsetf selection-owner (display selection &optional time) (owner)
  539.   ;; A bit strange, but retains setf form.
  540.   `(set-selection-owner ,display ,selection ,owner ,time))
  541.  
  542. (defun convert-selection (selection type requestor &optional property time)
  543.   (declare (type xatom selection type)
  544.        (type window requestor)
  545.        (type (or null xatom) property)
  546.        (type timestamp time))
  547.   (let* ((display (window-display requestor))
  548.      (selection-id (intern-atom display selection))
  549.      (type-id (intern-atom display type))
  550.      (property-id (and property (intern-atom display property))))
  551.     (declare (type display display)
  552.          (type resource-id selection-id type-id)
  553.          (type (or null resource-id) property-id))
  554.     (with-buffer-request (display *x-convertselection*)
  555.       (window requestor)
  556.       (resource-id selection-id type-id)
  557.       ((or null resource-id) property-id)
  558.       ((or null card32) time))))
  559.  
  560. (defun send-event (window event-key event-mask &rest args
  561.            &key propagate-p display &allow-other-keys)
  562.   ;; Additional arguments depend on event-key, and are as specified further below
  563.   ;; with declare-event, except that both resource-ids and resource objects are
  564.   ;; accepted in the event components.  The display argument is only required if the
  565.   ;; window is :pointer-window or :input-focus.
  566.   (declare (type (or window (member :pointer-window :input-focus)) window)
  567.        (type event-key event-key)
  568.        (type (or null event-mask) event-mask)
  569.        (type boolean propagate-p)
  570.        (type (or null display) display)
  571.        (special *event-send-vector*))
  572.   (unless event-mask (setq event-mask 0))
  573.   (unless display (setq display (window-display window)))
  574.   (let ((internal-event-code (get-event-code event-key))
  575.     (external-event-code (get-external-event-code display event-key)))
  576.     (declare (type card8 internal-event-code external-event-code))
  577.     (with-display (display)
  578.       ;; Ensure keyword atom-id's are cached
  579.       (dolist (arg (cdr (assoc event-key '((:property-notify :atom)
  580.                        (:selection-clear :selection)
  581.                        (:selection-request :selection :target :property)
  582.                        (:selection-notify :selection :target :property))
  583.                    :test #'eq)))
  584.     (let ((keyword (getf args arg)))
  585.       (intern-atom display keyword)))
  586.       ;; Make the sendevent request
  587.       (with-buffer-request (display *x-sendevent*)
  588.     ((data boolean) propagate-p)
  589.     (length 11) ;; 3 word request + 8 words for event = 11
  590.     ((or (member :pointer-window :input-focus) window) window)
  591.     (card32 (encode-event-mask event-mask))
  592.     (card8 external-event-code)
  593.     (progn
  594.       (apply (aref *event-send-vector* internal-event-code) display args)
  595.       (incf (buffer-boffset display) 44))))))
  596.  
  597. (defun grab-pointer (window event-mask
  598.              &key owner-p sync-pointer-p sync-keyboard-p confine-to cursor time)
  599.   (declare (type window window)
  600.        (type pointer-event-mask event-mask)
  601.        (type boolean owner-p sync-pointer-p sync-keyboard-p)
  602.        (type (or null window) confine-to)
  603.        (type (or null cursor) cursor)
  604.        (type timestamp time))
  605.   (declare-values grab-status)
  606.   (let ((display (window-display window))
  607.     grab-status)
  608.     (with-display (display)
  609.       (with-buffer-request (display *x-grabpointer* :no-after)
  610.     ((data boolean) owner-p)
  611.     (window window)
  612.     (card16 (encode-pointer-event-mask event-mask))
  613.     (boolean (not sync-pointer-p) (not sync-keyboard-p))
  614.     ((or null window) confine-to)
  615.     ((or null cursor) cursor)
  616.     ((or null card32) time)
  617.     )
  618.       (with-buffer-reply (display nil :sizes 8)
  619.     (setq grab-status (member8-get 1 :success :already-grabbed
  620.                      :invalid-time :not-viewable :frozen))))
  621.     (display-invoke-after-function display)
  622.     grab-status))
  623.  
  624. (defun ungrab-pointer (display &key time)
  625.   (declare (type timestamp time))
  626.   (with-buffer-request (display *x-ungrabpointer*)
  627.     ((or null card32) time)))
  628.  
  629. (defun grab-button (window button event-mask
  630.             &key (modifiers 0)
  631.              owner-p sync-pointer-p sync-keyboard-p confine-to cursor)
  632.   (declare (type window window)
  633.        (type (or (member :any) card8) button)
  634.        (type modifier-mask modifiers)
  635.        (type pointer-event-mask event-mask)
  636.        (type boolean owner-p sync-pointer-p sync-keyboard-p)
  637.        (type (or null window) confine-to)
  638.        (type (or null cursor) cursor))
  639.   (with-buffer-request ((window-display window) *x-grabbutton*)
  640.     ((data boolean) owner-p)
  641.     (window window)
  642.     (card16 (encode-pointer-event-mask event-mask))
  643.     (boolean (not sync-pointer-p) (not sync-keyboard-p))
  644.     ((or null window) confine-to)
  645.     ((or null cursor) cursor)
  646.     (card8 (if (eq button :any) 0 button))
  647.     (pad8 1)
  648.     (card16 (encode-modifier-mask modifiers))
  649.     ))
  650.  
  651. (defun ungrab-button (window button &key (modifiers 0))
  652.   (declare (type window window)
  653.        (type (or (member :any) card8) button)
  654.        (type modifier-mask modifiers))
  655.   (with-buffer-request ((window-display window) *x-ungrabbutton*)
  656.     (data (if (eq button :any) 0 button))
  657.     (window window)
  658.     (card16 (encode-modifier-mask modifiers))))
  659.  
  660. (defun change-active-pointer-grab (display event-mask &optional cursor time)
  661.   (declare (type display display)
  662.        (type pointer-event-mask event-mask)
  663.        (type (or null cursor) cursor)
  664.        (type timestamp time))
  665.   (with-buffer-request (display *x-changeactivepointergrab*)
  666.     ((or null cursor) cursor)
  667.     ((or null card32) time)
  668.     (card16 (encode-pointer-event-mask event-mask))))
  669.  
  670. (defun grab-keyboard (window &key owner-p sync-pointer-p sync-keyboard-p time)
  671.   (declare (type window window)
  672.        (type boolean owner-p sync-pointer-p sync-keyboard-p)
  673.        (type timestamp time))
  674.   (declare-values grab-status)
  675.   (let ((display (window-display window))
  676.     grab-status)
  677.     (with-display (display)
  678.       (with-buffer-request (display *x-grabkeyboard* :no-after)
  679.     ((data boolean) owner-p)
  680.     (window window)
  681.     ((or null card32) time)
  682.     (boolean (not sync-pointer-p) (not sync-keyboard-p)))
  683.       (with-buffer-reply (display nil :sizes 8)
  684.     (setq grab-status (member8-get 1 :success :already-grabbed
  685.                      :invalid-time :not-viewable :frozen))))
  686.     (display-invoke-after-function display)
  687.     grab-status))
  688.  
  689. (defun ungrab-keyboard (display &key time)
  690.   (declare (type display display)
  691.        (type timestamp time))
  692.   (with-buffer-request (display *x-ungrabkeyboard*)
  693.     ((or null card32) time)))
  694.  
  695. (defun grab-key (window key &key (modifiers 0) owner-p sync-pointer-p sync-keyboard-p)
  696.   (declare (type window window)
  697.        (type boolean owner-p sync-pointer-p sync-keyboard-p)
  698.        (type (or (member :any) card8) key)
  699.        (type modifier-mask modifiers))
  700.   (with-buffer-request ((window-display window) *x-grabkey*)
  701.     ((data boolean) owner-p)
  702.     (window window)
  703.     (card16 (encode-modifier-mask modifiers))
  704.     (card8 (if (eq key :any) 0 key))
  705.     (boolean (not sync-pointer-p) (not sync-keyboard-p))
  706.     ))
  707.  
  708. (defun ungrab-key (window key &key (modifiers 0))
  709.   (declare (type window window)
  710.        (type (or (member :any) card8) key)
  711.        (type modifier-mask modifiers))
  712.   (with-buffer-request ((window-display window) *x-ungrabkey*)
  713.     (data (if (eq key :any) 0 key))
  714.     (window window)
  715.     (card16 (encode-modifier-mask modifiers))))
  716.  
  717. (defun allow-events (display mode &optional time)
  718.   (declare (type display display)
  719.        (type (member :async-pointer :sync-pointer :replay-pointer
  720.              :async-keyboard :sync-keyboard :replay-keyboard
  721.              :async-both :sync-both)
  722.          mode)
  723.        (type timestamp time))
  724.   (with-buffer-request (display *x-allowevents*)
  725.     ((data (member :async-pointer :sync-pointer :replay-pointer
  726.            :async-keyboard :sync-keyboard :replay-keyboard
  727.            :async-both :sync-both))
  728.      mode)
  729.     ((or null card32) time)))
  730.  
  731. (defun grab-server (display)
  732.   (declare (type display display))
  733.   (with-buffer-request (display *x-grabserver*)))
  734.  
  735. (defun ungrab-server (display)
  736.   (with-buffer-request (display *x-ungrabserver*)))
  737.  
  738. (defmacro with-server-grabbed ((display) &body body)
  739.   ;; The body is not surrounded by a with-display.
  740.   (let ((disp (gensym)))
  741.     `(let ((,disp ,display))
  742.        (unwind-protect
  743.        (progn
  744.          (grab-server ,disp)
  745.          ,@body)
  746.      (ungrab-server ,disp)))))
  747.  
  748. (defun query-pointer (window)
  749.   (declare (type window window))
  750.   (declare-values x y same-screen-p child mask root-x root-y root)
  751.   (let ((display (window-display window))
  752.     x y same-screen-p child mask root-x root-y root)
  753.     (with-display (display)
  754.       (with-buffer-request (display *x-querypointer* :no-after)
  755.     (window window))
  756.       (with-buffer-reply (display 26 :sizes (8 16 32))
  757.     (setq same-screen-p (boolean-get 1)
  758.           root (window-get 8)
  759.           child (or-get 12 null window)
  760.           root-x (int16-get 16)
  761.           root-y (int16-get 18)
  762.           x (int16-get 20)
  763.           y (int16-get 22)
  764.           mask (card16-get 24))))
  765.     (display-invoke-after-function display)
  766.     (values x y same-screen-p child mask root-x root-y root)))
  767.  
  768. (defun pointer-position (window)
  769.   (declare (type window window))
  770.   (declare-values x y same-screen-p)
  771.   (let ((display (window-display window))
  772.     x y same-screen-p)
  773.     (with-display (display)
  774.       (with-buffer-request (display *x-querypointer* :no-after)
  775.     (window window))
  776.       (with-buffer-reply (display 24 :sizes (8 16))
  777.     (setq x (int16-get 20)
  778.           y (int16-get 22)
  779.           same-screen-p (boolean-get 1))))
  780.     (display-invoke-after-function display)
  781.     (values x y same-screen-p)))
  782.  
  783. (defun global-pointer-position (display)
  784.   (declare (type display display))
  785.   (declare-values root-x root-y root)
  786.   (let (root root-x root-y)
  787.     (with-display (display)
  788.       (with-buffer-request (display *x-querypointer* :no-after)
  789.     (window (screen-root (first (display-roots display)))))
  790.       (with-buffer-reply (display 20 :sizes (16 32))
  791.     (setq root (window-get 8)
  792.           root-x (int16-get 16)
  793.           root-y (int16-get 18))))
  794.     (display-invoke-after-function display)
  795.     (values root-x root-y root)))
  796.  
  797. (defun motion-events (window &key start stop (result-type 'list))
  798.   (declare (type window window)
  799.        (type timestamp start stop)
  800.        (type t result-type)) ;; a type specifier
  801.   (declare-values (repeat-seq (integer x) (integer y) (timestamp time)))
  802.   (let ((display (window-display window))
  803.     seq)
  804.     (with-display (display)
  805.       (with-buffer-request (display *x-getmotionevents* :no-after)
  806.     (window window)
  807.     ((or null card32) start stop))
  808.       (with-buffer-reply (display nil :sizes 32)
  809.     (let ((nevents (card32-get 8)))
  810.       (setq seq (sequence-get :result-type result-type :length (* nevents 3))))))
  811.     (display-invoke-after-function display)
  812.     seq))
  813.  
  814. (defun translate-coordinates (src src-x src-y dst)
  815.   ;; Returns NIL when not on the same screen
  816.   (declare (type window src)
  817.        (type int16 src-x src-y)
  818.        (type window dst))
  819.   (declare-values dst-x dst-y child)
  820.   (let ((display (window-display src))
  821.     dst-x dst-y child)
  822.     (with-display (display)
  823.       (with-buffer-request (display *x-translatecoords* :no-after)
  824.     (window src dst)
  825.     (int16 src-x src-y))
  826.       (with-buffer-reply (display 16 :sizes (8 16 32))
  827.     (when (boolean-get 1)
  828.       (setq dst-x (int16-get 12)
  829.         dst-y (int16-get 14)
  830.         child (window-get 8)))))
  831.     (display-invoke-after-function display)
  832.     (values dst-x dst-y child)))
  833.  
  834. (defun warp-pointer (dst dst-x dst-y)
  835.   (declare (type window dst)
  836.        (type int16 dst-x dst-y))
  837.   (with-buffer-request ((window-display dst) *x-warppointer*)
  838.     (resource-id 0) ;; None
  839.     (window dst)
  840.     (int16 0 0)
  841.     (card16 0 0)
  842.     (int16 dst-x dst-y)))
  843.  
  844. (defun warp-pointer-relative (display x-off y-off)
  845.   (declare (type display display)
  846.        (type int16 x-off y-off))
  847.   (with-buffer-request (display *x-warppointer*)
  848.     (resource-id 0) ;; None
  849.     (resource-id 0) ;; None
  850.     (int16 0 0)
  851.     (card16 0 0)
  852.     (int16 x-off y-off)))
  853.  
  854. (defun warp-pointer-if-inside (dst dst-x dst-y src src-x src-y
  855.                    &optional src-width src-height)
  856.   ;; Passing in a zero src-width or src-height is a no-op.
  857.   ;; A null src-width or src-height translates into a zero value in the protocol request.
  858.   (declare (type window dst src)
  859.        (type int16 dst-x dst-y src-x src-y)
  860.        (type (or null card16) src-width src-height))
  861.   (unless (or (eql src-width 0) (eql src-height 0))
  862.     (with-buffer-request ((window-display dst) *x-warppointer*)
  863.       (window src dst)
  864.       (int16 src-x src-y)
  865.       (card16 (or src-width 0) (or src-height 0))
  866.       (int16 dst-x dst-y))))
  867.  
  868. (defun warp-pointer-relative-if-inside (x-off y-off src src-x src-y
  869.                     &optional src-width src-height)
  870.   ;; Passing in a zero src-width or src-height is a no-op.
  871.   ;; A null src-width or src-height translates into a zero value in the protocol request.
  872.   (declare (type window src)
  873.        (type int16 x-off y-off src-x src-y)
  874.        (type (or null card16) src-width src-height))
  875.   (unless (or (eql src-width 0) (eql src-height 0))
  876.     (with-buffer-request ((window-display src) *x-warppointer*)
  877.       (window src)
  878.       (resource-id 0) ;; None
  879.       (int16 src-x src-y)
  880.       (card16 (or src-width 0) (or src-height 0))
  881.       (int16 x-off y-off))))
  882.  
  883. (defun set-input-focus (display focus revert-to &optional time)
  884.   (declare (type display display)
  885.        (type (or (member :none :pointer-root) window) focus)
  886.        (type (member :none :parent :pointer-root) revert-to)
  887.        (type timestamp time))
  888.   (with-buffer-request (display *x-setinputfocus*)
  889.     ((data (member :none :parent :pointer-root)) revert-to)
  890.     ((or window (member :none :pointer-root)) focus)
  891.     ((or null card32) time)))
  892.  
  893. (defun input-focus (display)
  894.   (declare (type display display))
  895.   (declare-values focus revert-to)
  896.   (let (focus revert-to)
  897.     (with-display (display)
  898.       (with-buffer-request (display *x-getinputfocus* :no-after))
  899.       (with-buffer-reply (display 16 :sizes (8 32))
  900.     (setq focus (or-get 8 (member :none :pointer-root) window)
  901.           revert-to (member8-get 1 :none :pointer-root :parent))))
  902.     (display-invoke-after-function display)
  903.     (values focus revert-to)))
  904.  
  905. (defun query-keymap (display &optional bit-vector)
  906.   (declare (type display display)
  907.        (type (or null (bit-vector 256)) bit-vector))
  908.   (declare-values (bit-vector 256))
  909.   (let (result)
  910.     (with-display (display)
  911.       (with-buffer-request (display *x-querykeymap* :no-after))
  912.       (with-buffer-reply (display 40 :sizes 8)
  913.     (setq result (bit-vector256-get 8 8 bit-vector))))
  914.     (display-invoke-after-function display)
  915.     result))
  916.  
  917. (defun create-pixmap (&key
  918.               (width (required-arg width))
  919.               (height (required-arg height))
  920.               (depth (required-arg depth))
  921.               (drawable (required-arg drawable)))
  922.   (declare (type card8 depth) ;; required
  923.        (type card16 width height) ;; required
  924.        (type drawable drawable)) ;; required
  925.   (declare-values pixmap)
  926.   (let* ((display (drawable-display drawable))
  927.      (pixmap (make-pixmap :display display))
  928.      (pid (allocate-resource-id display pixmap 'pixmap)))
  929.     (setf (pixmap-id pixmap) pid)
  930.     (with-buffer-request (display *x-createpixmap*)
  931.       (data depth)
  932.       (resource-id pid)
  933.       (drawable drawable)
  934.       (card16 width height))
  935.     pixmap))
  936.  
  937. (defun free-pixmap (pixmap)
  938.   (declare (type pixmap pixmap))
  939.   (let ((display (pixmap-display pixmap)))
  940.     (with-buffer-request (display *x-freepixmap*)
  941.       (pixmap pixmap))
  942.     (deallocate-resource-id display (pixmap-id pixmap) 'pixmap)))
  943.  
  944. (defun clear-area (window &key (x 0) (y 0) width height exposures-p)
  945.   ;; Passing in a zero width or height is a no-op.
  946.   ;; A null width or height translates into a zero value in the protocol request.
  947.   (declare (type window window)
  948.        (type int16 x y)
  949.        (type (or null card16) width height)
  950.        (type boolean exposures-p))
  951.   (unless (or (eql width 0) (eql height 0))
  952.     (with-buffer-request ((window-display window) *x-cleartobackground*)
  953.       ((data boolean) exposures-p)
  954.       (window window)
  955.       (int16 x y)
  956.       (card16 (or width 0) (or height 0)))))
  957.  
  958. (defun copy-area (src gcontext src-x src-y width height dst dst-x dst-y)
  959.   (declare (type drawable src dst)
  960.        (type gcontext gcontext)
  961.        (type int16 src-x src-y dst-x dst-y)
  962.        (type card16 width height))
  963.   (with-buffer-request ((drawable-display src) *x-copyarea* :gc-force gcontext)
  964.     (drawable src dst)
  965.     (gcontext gcontext)
  966.     (int16 src-x src-y dst-x dst-y)
  967.     (card16 width height)))
  968.  
  969. (defun copy-plane (src gcontext plane src-x src-y width height dst dst-x dst-y)
  970.   (declare (type drawable src dst)
  971.        (type gcontext gcontext)
  972.        (type pixel plane)
  973.        (type int16 src-x src-y dst-x dst-y)
  974.        (type card16 width height))
  975.   (with-buffer-request ((drawable-display src) *x-copyplane* :gc-force gcontext)
  976.     (drawable src dst)
  977.     (gcontext gcontext)
  978.     (int16 src-x src-y dst-x dst-y)
  979.     (card16 width height)
  980.     (card32 plane)))
  981.  
  982. (defun create-colormap (visual window &optional alloc-p)
  983.   (declare (type card29 visual)
  984.        (type window window)
  985.        (type boolean alloc-p))
  986.   (declare-values colormap)
  987.   (let* ((display (window-display window))
  988.      (colormap (make-colormap :display display))
  989.      (id (allocate-resource-id display colormap 'colormap)))
  990.     (setf (colormap-id colormap) id)
  991.     (with-buffer-request (display *x-createcolormap*)
  992.       ((data boolean) alloc-p)
  993.       (resource-id id)
  994.       (window window)
  995.       (card29 visual))
  996.     colormap))
  997.  
  998. (defun free-colormap (colormap)
  999.   (declare (type colormap colormap))
  1000.   (let ((display (colormap-display colormap)))
  1001.     (with-buffer-request (display *x-freecolormap*)
  1002.       (colormap colormap))
  1003.     (deallocate-resource-id display (colormap-id colormap) 'colormap)))
  1004.  
  1005. (defun copy-colormap-and-free (colormap)
  1006.   (declare (type colormap colormap))
  1007.   (declare-values colormap)
  1008.   (let* ((display (colormap-display colormap))
  1009.      (new-colormap (make-colormap :display display))
  1010.      (id (allocate-resource-id display new-colormap 'colormap)))
  1011.     (setf (colormap-id new-colormap) id)
  1012.     (with-buffer-request (display *x-copycolormapandfree*)
  1013.       (resource-id id)
  1014.       (colormap colormap))
  1015.     new-colormap))
  1016.  
  1017. (defun install-colormap (colormap)
  1018.   (declare (type colormap colormap))
  1019.   (with-buffer-request ((colormap-display colormap) *x-installcolormap*)
  1020.     (colormap colormap)))
  1021.  
  1022. (defun uninstall-colormap (colormap)
  1023.   (declare (type colormap colormap))
  1024.   (with-buffer-request ((colormap-display colormap) *x-uninstallcolormap*)
  1025.     (colormap colormap)))
  1026.  
  1027. (defun installed-colormaps (window &key (result-type 'list))
  1028.   (declare (type window window)
  1029.        (type t result-type)) ;; CL type
  1030.   (declare-values (sequence colormap))
  1031.   (let ((display (window-display window))
  1032.     seq)
  1033.     (labels ((get-colormap (id)
  1034.                (or (lookup-resource-id display id)
  1035.                    (save-id display id (make-colormap :display display :id id)))))
  1036.       (with-display (display)
  1037.     (with-buffer-request (display *x-listinstalledcolormaps* :no-after)
  1038.       (window window))
  1039.     (with-buffer-reply (display nil :sizes 16)
  1040.       (let ((nmaps (card16-get 8)))
  1041.         (setq seq (sequence-get :result-type result-type :length nmaps :transform #'get-colormap))))))
  1042.     (display-invoke-after-function display)
  1043.     seq))
  1044.  
  1045. (defun alloc-color (colormap color)
  1046.   (declare (type colormap colormap)
  1047.        (type (or stringable color) color))
  1048.   (declare-values pixel screen-color exact-color)
  1049.   (let ((display (colormap-display colormap))
  1050.     pixel screen-color exact-color)
  1051.     (with-display (display)
  1052.       (etypecase color
  1053.     (color
  1054.      (with-buffer-request (display *x-alloccolor* :no-after)
  1055.        (colormap colormap)
  1056.        (rgb-val (color-red color)
  1057.             (color-green color)
  1058.             (color-blue color))
  1059.        (pad16 nil))
  1060.      (with-buffer-reply (display 20 :sizes (16 32))
  1061.        (setq pixel (card32-get 16)
  1062.          screen-color (make-color :red (rgb-val-get 8)
  1063.                       :green (rgb-val-get 10)
  1064.                       :blue (rgb-val-get 12))
  1065.          exact-color color)))
  1066.      (stringable
  1067.       (let* ((string (string color))
  1068.          (length (length string)))
  1069.        (with-buffer-request (display *x-allocnamedcolor* :no-after)
  1070.          (colormap colormap)
  1071.          (card16 length)
  1072.          (pad16 nil)
  1073.          (string string))
  1074.        (with-buffer-reply (display 24 :sizes (16 32))
  1075.          (setq pixel (card32-get 8)
  1076.            screen-color (make-color :red (rgb-val-get 12)
  1077.                         :green (rgb-val-get 14)
  1078.                         :blue (rgb-val-get 16))
  1079.            exact-color (make-color :red (rgb-val-get 18)
  1080.                        :green (rgb-val-get 20)
  1081.                        :blue (rgb-val-get 22))))))))
  1082.     (display-invoke-after-function display)
  1083.     (values pixel screen-color exact-color)))
  1084.  
  1085. (defun alloc-color-cells (colormap colors &key (planes 0) contiguous-p (result-type 'list))
  1086.   (declare (type colormap colormap)
  1087.        (type card16 colors planes)
  1088.        (type boolean contiguous-p)
  1089.        (type t result-type)) ;; CL type
  1090.   (declare-values (sequence pixel) (sequence mask))
  1091.   (let ((display (colormap-display colormap))
  1092.     pixel-sequence mask-sequence)
  1093.     (with-display (display)
  1094.       (with-buffer-request (display *x-alloccolorcells* :no-after)
  1095.     ((data boolean) contiguous-p)
  1096.     (colormap colormap)
  1097.     (card16 colors planes))
  1098.       (with-buffer-reply (display nil :sizes 16)
  1099.     (let ((npixels (card16-get 8))
  1100.           (nmasks (card16-get 10)))
  1101.       (setq pixel-sequence 
  1102.         (sequence-get :result-type result-type :length npixels))
  1103.       (setq mask-sequence
  1104.         (sequence-get :result-type result-type :length nmasks)))))
  1105.     (display-invoke-after-function display)
  1106.     (values pixel-sequence mask-sequence)))
  1107.  
  1108. (defun alloc-color-planes (colormap colors
  1109.                &key (reds 0) (greens 0) (blues 0)
  1110.                 contiguous-p (result-type 'list))
  1111.   (declare (type colormap colormap)
  1112.        (type card16 colors reds greens blues)
  1113.        (type boolean contiguous-p)
  1114.        (type t result-type)) ;; CL type
  1115.   (declare-values (sequence pixel) red-mask green-mask blue-mask)
  1116.   (let ((display (colormap-display colormap))
  1117.     seq red-mask green-mask blue-mask)
  1118.     (with-display (display)
  1119.       (with-buffer-request (display *x-alloccolorplanes* :no-after)
  1120.     ((data boolean) contiguous-p)
  1121.     (colormap colormap)
  1122.     (card16 colors reds greens blues))
  1123.       (with-buffer-reply (display nil :sizes (16 32))
  1124.     (let ((npixels (card16-get 8)))
  1125.       (setq red-mask (card32-get 12)
  1126.         green-mask (card32-get 16)
  1127.         blue-mask (card32-get 20)
  1128.         seq (sequence-get :result-type result-type :length npixels)))))
  1129.     (display-invoke-after-function display)
  1130.     (values seq red-mask green-mask blue-mask)))
  1131.  
  1132. (defun free-colors (colormap pixels &optional (plane-mask 0))
  1133.   (declare (type colormap colormap)
  1134.        (type sequence pixels) ;; Sequence of integers
  1135.        (type pixel plane-mask))
  1136.   (with-buffer-request ((colormap-display colormap) *x-freecolors*)
  1137.     (colormap colormap)
  1138.     (card32 plane-mask)
  1139.     (sequence pixels)))
  1140.  
  1141. (defun store-color (colormap pixel spec &key (red-p t) (green-p t) (blue-p t))
  1142.   (declare (type colormap colormap)
  1143.        (type pixel pixel)
  1144.        (type (or stringable color) spec)
  1145.        (type boolean red-p green-p blue-p))
  1146.   (let ((display (colormap-display colormap))
  1147.     (flags 0))
  1148.     (declare (type display display)
  1149.          (type card8 flags))
  1150.     (when red-p (setq flags 1))
  1151.     (when green-p (incf flags 2))
  1152.     (when blue-p (incf flags 4))
  1153.     (with-display (display)
  1154.       (etypecase spec
  1155.     (color
  1156.      (with-buffer-request (display *x-storecolors*)
  1157.        (colormap colormap)
  1158.        (card32 pixel)
  1159.        (rgb-val (color-red spec)
  1160.             (color-green spec)
  1161.             (color-blue spec))
  1162.        (card8 flags)
  1163.        (pad8 nil)))
  1164.      (stringable
  1165.       (let* ((string (string spec))
  1166.          (length (length string)))
  1167.        (with-buffer-request (display *x-storenamedcolor*)
  1168.          (colormap colormap)
  1169.          (card32 pixel)
  1170.          (card16 length)
  1171.          (pad16 nil)
  1172.          (string string))))
  1173.      ))))
  1174.  
  1175. (defun store-colors (colormap specs &key (red-p t) (green-p t) (blue-p t))
  1176.   ;; If stringables are specified for colors, it is unspecified whether all
  1177.   ;; stringables are first resolved and then a single StoreColors protocol request is
  1178.   ;; issued, or whether multiple StoreColors protocol requests are issued.
  1179.   (declare (type colormap colormap)
  1180.        (type sequence specs) ;; (repeat-seq (integer pixel) ((or stringable color) color)) specs)
  1181.        (type boolean red-p green-p blue-p))
  1182.   (etypecase specs
  1183.     (list
  1184.      (do* ((spec specs (cddr spec))
  1185.        (pixel (car spec) (car spec))
  1186.        (color (cadr spec) (cadr spec)))
  1187.       ((endp spec))
  1188.        (store-color colormap pixel color :red-p red-p :green-p green-p :blue-p blue-p)))
  1189.     (vector
  1190.      (do* ((i 0 (+ i 2))
  1191.        (len (length specs))
  1192.        (pixel (aref specs i) (aref specs i))
  1193.        (color (aref specs (1+ i)) (aref specs (1+ i))))
  1194.       ((>= i len))
  1195.        (store-color colormap pixel color :red-p red-p :green-p green-p :blue-p blue-p)))))
  1196.  
  1197. (defun query-colors (colormap pixels &key (result-type 'list))
  1198.   (declare (type colormap colormap)
  1199.        (type sequence pixels) ;; sequence of integer
  1200.        (type t result-type))   ;; a type specifier
  1201.   (declare-values (sequence color))
  1202.   (let ((display (colormap-display colormap))
  1203.     sequence)
  1204.     (with-display (display)
  1205.       (with-buffer-request (display *x-querycolors* :no-after)
  1206.     (colormap colormap)
  1207.     (sequence pixels))
  1208.       (wait-for-reply display nil)
  1209.       (reading-buffer-reply (display :sizes (8 16))
  1210.     (let* ((ncolors (card16-get 8)))
  1211.       (setq sequence (make-sequence result-type ncolors))
  1212.       (dotimes (i ncolors sequence)
  1213.         (buffer-input display buffer-bbuf 0 8)
  1214.         (setf (elt sequence i)
  1215.           (make-color :red (rgb-val-get 0)
  1216.                   :green (rgb-val-get 2)
  1217.                   :blue (rgb-val-get 4)))))))
  1218.     (display-invoke-after-function display)
  1219.     sequence))
  1220.  
  1221. (defun lookup-color (colormap name)
  1222.   (declare (type colormap colormap)
  1223.        (type stringable name))
  1224.   (declare-values screen-color true-color)
  1225.   (let* ((display (colormap-display colormap))
  1226.      (string (string name))
  1227.      (length (length string))
  1228.      screen-color true-color)
  1229.     (with-display (display)
  1230.       (with-buffer-request (display *x-lookupcolor* :no-after)
  1231.     (colormap colormap)
  1232.     (card16 length)
  1233.     (pad16 nil)
  1234.     (string string))
  1235.       (with-buffer-reply (display 20 :sizes 16)
  1236.     (setq screen-color (make-color :red (rgb-val-get 14)
  1237.                        :green (rgb-val-get 16)
  1238.                        :blue (rgb-val-get 18))
  1239.           true-color (make-color :red (rgb-val-get 8)
  1240.                      :green (rgb-val-get 10)
  1241.                      :blue (rgb-val-get 12)))))
  1242.     (display-invoke-after-function display)
  1243.     (values screen-color true-color)))
  1244.  
  1245. (defun create-cursor (&key
  1246.               (source (required-arg source))
  1247.               mask
  1248.               (x (required-arg x))
  1249.               (y (required-arg y))
  1250.               (foreground (required-arg foreground))
  1251.               (background (required-arg background)))
  1252.   (declare (type pixmap source) ;; required
  1253.        (type (or null pixmap) mask)
  1254.        (type card16 x y) ;; required
  1255.        (type (or null color) foreground background)) ;; required
  1256.   (declare-values cursor)
  1257.   (let* ((display (pixmap-display source))
  1258.      (cursor (make-cursor :display display))
  1259.      (cid (allocate-resource-id display cursor 'cursor)))
  1260.     (setf (cursor-id cursor) cid)
  1261.     (with-buffer-request (display *x-createcursor*)
  1262.       (resource-id cid)
  1263.       (pixmap source)
  1264.       ((or null pixmap) mask)
  1265.       (rgb-val (color-red foreground)
  1266.            (color-green foreground)
  1267.            (color-blue foreground))
  1268.       (rgb-val (color-red background)
  1269.            (color-green background)
  1270.            (color-blue background))
  1271.       (card16 x y))
  1272.     cursor))
  1273.  
  1274. (defun create-glyph-cursor (&key
  1275.                 (source-font (required-arg source-font))
  1276.                 (source-char (required-arg source-char))
  1277.                 mask-font
  1278.                 mask-char
  1279.                 (foreground (required-arg foreground))
  1280.                 (background (required-arg background)))
  1281.   (declare (type font source-font) ;; Required
  1282.        (type card16 source-char) ;; Required
  1283.        (type (or null font) mask-font)
  1284.        (type (or null card16) mask-char)
  1285.        (type color foreground background)) ;; required
  1286.   (declare-values cursor)
  1287.   (let* ((display (font-display source-font))
  1288.      (cursor (make-cursor :display display))
  1289.      (cid (allocate-resource-id display cursor 'cursor))
  1290.      (source-font-id (font-id source-font))
  1291.      (mask-font-id (if mask-font (font-id mask-font) 0)))
  1292.     (setf (cursor-id cursor) cid)
  1293.     (unless mask-char (setq mask-char 0))
  1294.     (with-buffer-request (display *x-createglyphcursor*)
  1295.       (resource-id cid source-font-id mask-font-id)
  1296.       (card16 source-char)
  1297.       (card16 mask-char)
  1298.       (rgb-val (color-red foreground)
  1299.            (color-green foreground)
  1300.            (color-blue foreground))
  1301.       (rgb-val (color-red background)
  1302.            (color-green background)
  1303.            (color-blue background)))
  1304.     cursor))
  1305.  
  1306. (defun free-cursor (cursor)
  1307.   (declare (type cursor cursor))
  1308.   (let ((display (cursor-display cursor)))
  1309.     (with-buffer-request (display *x-freecursor*)
  1310.       (cursor cursor))
  1311.     (deallocate-resource-id display (cursor-id cursor) 'cursor)))
  1312.  
  1313. (defun recolor-cursor (cursor foreground background)
  1314.   (declare (type cursor cursor)
  1315.        (type color foreground background))
  1316.   (with-buffer-request ((cursor-display cursor) *x-recolorcursor*)
  1317.     (cursor cursor)
  1318.     (rgb-val (color-red foreground)
  1319.          (color-green foreground)
  1320.          (color-blue foreground))
  1321.     (rgb-val (color-red background)
  1322.          (color-green background)
  1323.          (color-blue background))
  1324.     ))
  1325.  
  1326. (defun query-best-cursor (width height display)
  1327.   (declare (type card16 width height)
  1328.        (type display display))
  1329.   (declare-values width height)
  1330.   (let (rwidth rheight)
  1331.     (with-display (display)
  1332.       (with-buffer-request (display *x-querybestsize* :no-after)
  1333.     (data 0)
  1334.     (window (screen-root (display-default-screen display)))
  1335.     (card16 width height))
  1336.       (with-buffer-reply (display 12 :sizes 16)
  1337.     (setq rwidth (card16-get 8)
  1338.           rheight (card16-get 10))))
  1339.     (display-invoke-after-function display)
  1340.     (values rwidth rheight)))
  1341.  
  1342. (defun query-best-tile (width height drawable)
  1343.   (declare (type card16 width height)
  1344.        (type drawable drawable))
  1345.   (declare-values width height)
  1346.   (let ((display (drawable-display drawable))
  1347.     rwidth rheight)
  1348.     (with-display (display)
  1349.       (with-buffer-request (display *x-querybestsize* :no-after)
  1350.     (data 1)
  1351.     (drawable drawable)
  1352.     (card16 width height))
  1353.       (with-buffer-reply (display 12 :sizes 16)
  1354.     (setq rwidth (card16-get 8)
  1355.           rheight (card16-get 10))))
  1356.     (display-invoke-after-function display)
  1357.     (values rwidth rheight)))
  1358.  
  1359. (defun query-best-stipple (width height drawable)
  1360.   (declare (type card16 width height)
  1361.        (type drawable drawable))
  1362.   (declare-values width height)
  1363.   (let ((display (drawable-display drawable))
  1364.     rwidth rheight)
  1365.     (with-display (display)
  1366.       (with-buffer-request (display *x-querybestsize* :no-after)
  1367.     (data 2)
  1368.     (drawable drawable)
  1369.     (card16 width height))
  1370.       (with-buffer-reply (display 12 :sizes 16)
  1371.     (setq rwidth (card16-get 8)
  1372.           rheight (card16-get 10))))
  1373.     (display-invoke-after-function display)
  1374.     (values rwidth rheight)))
  1375.  
  1376. (defun query-extension (display name)
  1377.   (declare (type display display)
  1378.        (type stringable name))
  1379.   (declare-values major-opcode first-event first-error)
  1380.   (let ((string (string name))
  1381.     major-opcode first-event first-error)
  1382.     (with-display (display)
  1383.       (with-buffer-request (display *x-queryextension* :no-after)
  1384.     (card16 (length string))
  1385.     (pad16 nil)
  1386.     (string string))
  1387.       (with-buffer-reply (display 12 :sizes 8)
  1388.     (when (boolean-get 8)    ;; If present
  1389.       (setq major-opcode (card8-get 9)
  1390.         first-event (card8-get 10)
  1391.         first-error (card8-get 11)))))
  1392.     (display-invoke-after-function display)
  1393.     (values major-opcode first-event first-error)))
  1394.  
  1395. (defun list-extensions (display &key (result-type 'list))
  1396.   (declare (type display display)
  1397.        (type t result-type)) ;; CL type
  1398.   (declare-values (sequence string))
  1399.   (let (result)
  1400.     (with-display (display)
  1401.       (with-buffer-request (display *x-listextensions* :no-after))
  1402.       (reading-buffer-reply (display :sizes 8)
  1403.     (let ((length (- (wait-for-reply display nil) *replysize*))
  1404.           (nextensions (card8-get 1)))
  1405.       (setq result (read-sequence-string display length nextensions result-type)))))
  1406.     (display-invoke-after-function display)
  1407.     result))
  1408.  
  1409. (defun change-keyboard-control (display &key key-click-percent
  1410.                 bell-percent bell-pitch bell-duration
  1411.                 led led-mode key auto-repeat-mode)
  1412.   (declare (type display display)
  1413.        (type (or null (member :default) int16) key-click-percent
  1414.                            bell-percent bell-pitch bell-duration)
  1415.        (type (or null card8) led key)
  1416.        (type (or null (member :on :off)) led-mode)
  1417.        (type (or null (member :on :off :default)) auto-repeat-mode))
  1418.   (when (eq key-click-percent :default) (setq key-click-percent -1))
  1419.   (when (eq bell-percent :default) (setq bell-percent -1))
  1420.   (when (eq bell-pitch :default) (setq bell-pitch -1))
  1421.   (when (eq bell-duration :default) (setq bell-duration -1))
  1422.   (with-buffer-request (display *x-changekeyboardcontrol* :sizes (32))
  1423.     (mask
  1424.       ((or null integer)
  1425.        key-click-percent bell-percent bell-pitch bell-duration)
  1426.       ((or null card32) led)
  1427.       ((or null (member :off :on)) led-mode)
  1428.       ((or null card32) key)
  1429.       ((or null (member :off :on :default)) auto-repeat-mode)
  1430.       )))
  1431.  
  1432. (defun keyboard-control (display)
  1433.   (declare (type display display))
  1434.   (declare-values key-click-percent bell-percent bell-pitch bell-duration
  1435.           led-mask global-auto-repeat auto-repeats)
  1436.   (let (key-click-percent bell-percent bell-pitch bell-duration
  1437.     led-mask global-auto-repeat auto-repeats)
  1438.     (with-display (display)
  1439.       (with-buffer-request (display *x-getkeyboardcontrol* :no-after))
  1440.       (with-buffer-reply (display 32 :sizes (8 16 32))
  1441.     (setq global-auto-repeat (member8-get 1 :off :on))
  1442.     (setq led-mask (card32-get 8))
  1443.     (setq key-click-percent (card8-get 12))
  1444.     (setq bell-percent (card8-get 13))
  1445.     (setq bell-pitch (card16-get 14))
  1446.     (setq bell-duration (card16-get 16))
  1447.     (setq auto-repeats (bit-vector256-get 32))))
  1448.     (display-invoke-after-function display)
  1449.     (values key-click-percent bell-percent bell-pitch bell-duration
  1450.         led-mask global-auto-repeat auto-repeats)))
  1451.  
  1452. ;;  The base volume should
  1453. ;; be considered to be the "desired" volume in the normal case; that is, a
  1454. ;; typical application should call XBell with 0 as the percent.  Rather
  1455. ;; than using a simple sum, the percent argument is instead used as the
  1456. ;; percentage of the remaining range to alter the base volume by.  That is,
  1457. ;; the actual volume is:
  1458. ;;     if percent>=0:    base - [(base * percent) / 100] + percent
  1459. ;;     if percent<0:     base + [(base * percent) / 100]
  1460.  
  1461. (defun bell (display &optional (percent-from-normal 0))
  1462.   ;; It is assumed that an eventual audio extension to X will provide more complete control.
  1463.   (declare (type display display)
  1464.        (type int8 percent-from-normal))
  1465.   (with-buffer-request (display *x-bell*)
  1466.     (data (int8->card8 percent-from-normal))))
  1467.  
  1468. (defun pointer-mapping (display &key (result-type 'list))
  1469.   (declare (type display display)
  1470.        (type t result-type)) ;; CL type
  1471.   (declare-values sequence) ;; Sequence of card
  1472.   (let (seq)
  1473.     (with-display (display)
  1474.       (with-buffer-request (display *x-getpointermapping* :no-after))
  1475.       (with-buffer-reply (display nil :sizes 8)
  1476.     (let ((nelts (card8-get 1)))
  1477.       (setq seq (sequence-get :length nelts :result-type result-type :format card8)))))
  1478.     (display-invoke-after-function display)
  1479.     seq))
  1480.  
  1481. (defun set-pointer-mapping (display map)
  1482.   ;; Can signal device-busy.
  1483.   (declare (type display display)
  1484.        (type sequence map)) ;; Sequence of card8
  1485.   (let (busy?)
  1486.     (with-display (display)
  1487.       (with-buffer-request (display *x-setpointermapping* :no-after)
  1488.     (data (length map))
  1489.     ((sequence :format card8) map))
  1490.       (with-buffer-reply (display 2 :sizes 8)
  1491.     (setq busy? (boolean-get 1))))
  1492.     (display-invoke-after-function display)
  1493.     (when busy?
  1494.       (x-error 'device-busy :display display))
  1495.     map))
  1496.  
  1497. (defsetf pointer-mapping set-pointer-mapping)
  1498.  
  1499. (defun change-pointer-control (display &key acceleration threshold)
  1500.   ;; Acceleration is rationalized if necessary.
  1501.   (declare (type display display)
  1502.        (type (or null (member :default) number) acceleration)
  1503.        (type (or null (member :default) integer) threshold)
  1504.        (inline rationalize16))
  1505.   (flet ((rationalize16 (number)
  1506.        ;; Rationalize NUMBER into the ratio of two signed 16 bit numbers
  1507.        (declare (type number number)
  1508.             (inline rationalize16))
  1509.        (declare-values numerator denominator)
  1510.        (do* ((rational (rationalize number))
  1511.          (numerator (numerator rational) (ash numerator -1))
  1512.          (denominator (denominator rational) (ash denominator -1)))
  1513.         ((or (= numerator 1)
  1514.              (and (< (abs numerator) #x8000)
  1515.               (< denominator #x8000)))
  1516.          (values numerator (min denominator #x7fff))))))
  1517.  
  1518.     (let ((acceleration-p 1)
  1519.       (threshold-p 1)
  1520.       (numerator 0)
  1521.       (denominator 1))
  1522.       (declare (type card8 acceleration-p threshold-p)
  1523.            (type int16 numerator denominator))
  1524.       (cond ((eq acceleration :default) (setq numerator -1))
  1525.         (acceleration (multiple-value-setq (numerator denominator)
  1526.                 (rationalize16 acceleration)))
  1527.         (t (setq acceleration-p 0)))
  1528.       (cond ((eq threshold :default) (setq threshold -1))
  1529.         ((null threshold) (setq threshold -1
  1530.                     threshold-p 0)))
  1531.       (with-buffer-request (display *x-changepointercontrol*)
  1532.     (int16 numerator denominator threshold)
  1533.     (card8 acceleration-p threshold-p)))))
  1534.  
  1535. (defun pointer-control (display)
  1536.   (declare (type display display))
  1537.   (declare-values acceleration threshold)
  1538.   (let (acceleration threshold)
  1539.     (with-display (display)
  1540.       (with-buffer-request (display *x-getpointercontrol* :no-after))
  1541.       (with-buffer-reply (display 16 :sizes 16)
  1542.     (setq acceleration (/ (card16-get 8) (card16-get 10)) ;; Should we float this?
  1543.           threshold (card16-get 12))))
  1544.     (display-invoke-after-function display)
  1545.     (values acceleration threshold)))
  1546.  
  1547. (defun set-screen-saver (display timeout interval blanking exposures)
  1548.   ;; Timeout and interval are in seconds, will be rounded to minutes.
  1549.   (declare (type display display)
  1550.        (type (or (member :default) int16) timeout interval)
  1551.        (type (member :yes :no :default) blanking exposures))
  1552.   (when (eq timeout :default) (setq timeout -1))
  1553.   (when (eq interval :default) (setq interval -1))
  1554.   (with-buffer-request (display *x-setscreensaver*)
  1555.     (int16 timeout interval)
  1556.     ((member8 :no :yes :default) blanking exposures)))
  1557.  
  1558. (defun screen-saver (display)
  1559.   ;; Returns timeout and interval in seconds.
  1560.   (declare (type display display))
  1561.   (declare-values timeout interval blanking exposures)
  1562.   (let (timeout interval blanking exposures)
  1563.     (with-display (display)
  1564.       (with-buffer-request (display *x-getscreensaver* :no-after))
  1565.       (with-buffer-reply (display 14 :sizes (8 16))
  1566.     (setq timeout (card16-get 8)
  1567.           interval (card16-get 10)
  1568.           blanking (member8-get 12 :no :yes :default)
  1569.           exposures (member8-get 13 :no :yes :default))))
  1570.     (display-invoke-after-function display)
  1571.     (values timeout interval blanking exposures)))
  1572.  
  1573. (defun activate-screen-saver (display)
  1574.   (declare (type display display))
  1575.   (with-buffer-request (display *x-forcescreensaver*)
  1576.     (data 1)))
  1577.  
  1578. (defun reset-screen-saver (display)
  1579.   (declare (type display display))
  1580.   (with-buffer-request (display *x-forcescreensaver*)
  1581.     (data 0)))
  1582.  
  1583. (defun add-access-host (display host &optional (family :internet))
  1584.   ;; A string must be acceptable as a host, but otherwise the possible types for
  1585.   ;; host are not constrained, and will likely be very system dependent.
  1586.   ;; This implementation uses a list whose car is the family keyword
  1587.   ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes.
  1588.   (declare (type display display)
  1589.        (type (or stringable list) host)
  1590.        (type (or null (member :internet :decnet :chaos) card8) family))
  1591.   (change-access-host display host family nil))
  1592.  
  1593. (defun remove-access-host (display host &optional (family :internet))
  1594.   ;; A string must be acceptable as a host, but otherwise the possible types for
  1595.   ;; host are not constrained, and will likely be very system dependent.
  1596.   ;; This implementation uses a list whose car is the family keyword
  1597.   ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes.
  1598.   (declare (type display display)
  1599.        (type (or stringable list) host)
  1600.        (type (or null (member :internet :decnet :chaos) card8) family))
  1601.   (change-access-host display host family t))
  1602.  
  1603. (defun change-access-host (display host family remove-p)
  1604.   (declare (type display display)
  1605.        (type (or stringable list) host)
  1606.        (type (or null (member :internet :decnet :chaos) card8) family))
  1607.   (unless (consp host)
  1608.     (setq host (host-address host family)))
  1609.   (let ((family (car host))
  1610.     (address (cdr host)))
  1611.     (with-buffer-request (display *x-changehosts*)
  1612.       ((data boolean) remove-p)
  1613.       (card8 (encode-type (or null (member :internet :decnet :chaos) card32) family))
  1614.       (card16 (length address))
  1615.       ((sequence :format card8) address))))
  1616.  
  1617. (defun access-hosts (display &optional (result-type 'list))
  1618.   ;; The type of host objects returned is not constrained, except that the hosts must
  1619.   ;; be acceptable to add-access-host and remove-access-host.
  1620.   ;; This implementation uses a list whose car is the family keyword
  1621.   ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes.
  1622.   (declare (type display display)
  1623.        (type t result-type)) ;; CL type
  1624.   (declare-values (sequence host) enabled-p)
  1625.   (let (sequence enabled-p)
  1626.   (with-display (display)
  1627.     (with-buffer-request (display *x-listhosts* :no-after))
  1628.     (with-buffer-reply (display nil :sizes (8 16))
  1629.       (setq enabled-p (boolean-get 1))
  1630.       (let* ((nhosts (card16-get 8)))
  1631.     (setq sequence (make-sequence result-type nhosts))
  1632.     (dotimes (i nhosts)
  1633.       (buffer-input display buffer-bbuf 0 4)
  1634.       (let ((family (card8-get 0))
  1635.         (len (card16-get 2)))
  1636.         (setf (elt sequence i)
  1637.           (cons (if (< family 3)
  1638.                 (aref '#(:internet :decnet :chaos) family)
  1639.               family)
  1640.             (sequence-get :length len :format card8 :result-type 'list))))))))
  1641.     (display-invoke-after-function display)
  1642.     (values sequence enabled-p)))
  1643.  
  1644. (defun access-control (display)
  1645.   (declare (type display display))
  1646.   (declare-values boolean) ;; True when access-control is ENABLED
  1647.   (let (result)
  1648.     (with-display (display)
  1649.       (with-buffer-request (display *x-listhosts* :no-after))
  1650.       (with-buffer-reply (display 2 :sizes 8)
  1651.     (setq result (boolean-get 1))))
  1652.     (display-invoke-after-function display)
  1653.     result))
  1654.   
  1655. (defun set-access-control (display enabled-p)
  1656.   (declare (type display display)
  1657.        (type boolean enabled-p))
  1658.   (with-buffer-request (display *x-changeaccesscontrol*)
  1659.     ((data boolean) enabled-p))
  1660.   enabled-p)
  1661.  
  1662. (defsetf access-control set-access-control)
  1663.  
  1664. (defun close-down-mode (display)
  1665.   ;; setf'able
  1666.   ;; Cached locally in display object.
  1667.   (declare (type display display))
  1668.   (declare-values (member :destroy :retain-permanent :retain-temporary nil))
  1669.   (display-close-down-mode display))
  1670.  
  1671. (defun set-close-down-mode (display mode)
  1672.   ;; Cached locally in display object.
  1673.   (declare (type display display)
  1674.        (type (member :destroy :retain-permanent :retain-temporary) mode))
  1675.   (setf (display-close-down-mode display) mode)
  1676.   (with-buffer-request (display *x-changeclosedownmode* :sizes (32))
  1677.     ((data (member :destroy :retain-permanent :retain-temporary)) mode))
  1678.   mode)
  1679.  
  1680. (defsetf close-down-mode set-close-down-mode)
  1681.  
  1682. (defun kill-client (display resource-id)
  1683.   (declare (type display display)
  1684.        (type resource-id resource-id))
  1685.   (with-buffer-request (display *x-killclient*)
  1686.     (resource-id resource-id)))
  1687.  
  1688. (defun kill-temporary-clients (display)
  1689.   (declare (type display display))
  1690.   (with-buffer-request (display *x-killclient*)
  1691.     (resource-id 0)))
  1692.  
  1693. #+comment ;; This is a protocol request, but its not very interesting...
  1694. (defun no-operation (display)
  1695.   (declare (type display display))
  1696.   (with-buffer-request (display *x-nooperation*)))
  1697.